２９−５1．ＣＳＶファイルを早く開く方法
○●●Excel97以降ＣＳＶファイルの読み取りが遅くなって イライラしていたので、早く開く方法がないか検討しました。
結果：テキストファイルへ変換し文字列で読み取る方法が一番よかった。

(1)．一般的なＣＳＶ読み込みマクロ【84.19秒】----------------4番
(2)．キ−ボ−ドから指定して読み取る方法のマクロ【2.85秒】----3番
(3)．テキストファイルへ変換し文字列で読み取る【0.38秒】------1番
(4)．ファイルを開かずに読み取りセルへ1行ずつ書く【121.98秒】--6番
(5)．ファイルを開かずに読み取り後からセルへ記入【116.82秒】---5番
(6)．ファイルを開かずに読み取りセルへまとめて記入【0.60秒】---2番

・今回時間測定したものは、郵便HPからダウンロ−ドした280kbCSVファイルです。
・(1)の通常のマクロもExcel95では開くのに1秒以下であり特に気にならない。

(1)．一般的なＣＳＶ読み込みマクロ
○●● 下記は自動記録で作成した一般的マクロ例でExcel97/2000では凄く時間が掛かる。 

Sub 例51k1()
    Workbooks.Open Filename:="D:\test2\郵便番号\13TOKYO.csv"
End Sub

(2)．キ−ボ−ドから指定して読み取る方法のマクロ
○●● Excel97/2000でCSVファイルを読み込むとかなり遅いが、何故かキ−ボ−ドから手動で ファイルを指定して読み込むとそんなに遅くない。今回どの方法が一番早いかの 検討の一環としてキ−ボ−ド操作もマクロ化して見た。（実際はPCを使う人に よりキ−ボ−ドの設定が日本語入力等になっていることがあり、汎用ソフトと してこのマクロを使うのは止めた方がよい） 

Sub 例51k2()
ChDrive "D:"
ChDir "\test2\郵便番号"
Const fname1 As String = "13TOKYO.csv"

SendKeys "%(FO)"
SendKeys "13TOKYO.CSV"
SendKeys "{enter}", True
ThisWorkbook.Activate
End Sub 
・上記は、パス及びファイル名は対象のCSVファイルに変更して使用のこと。
・カレントフォルダ−を対象に実行する為、ChDrive、ChDirが必要

(3)．テキストファイルへ変換し文字列で読み取る
○●● テキストファイルを全フィ−ルド「文字列」で読み込むと速いので、 (.csv)を(.txt)に変換し読み取った例。 

Sub 例51k3()
Const phn As String = "D:\test2\郵便番号"
Const fname1 As String = "13TOKYO.csv"
Const fname2 As String = "13TOKYO.txt"

If Dir(phn & "\" & fname1) <> fname1 Then
    MsgBox "ファイル「" & fname1 & "」はありませんありません"
    Exit Sub
End If
 Application.StatusBar = "ファイル名( " & fname1 & " )読み込み中"
    Name phn & "\" & fname1 As phn & "\" & fname2
        
        Workbooks.OpenText FileName:=phn & "\" & fname2, DataType:=xlDelimited, _
        Comma:=True,FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), _
        Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), _
        Array(9, 2), Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), _
        Array(14, 2), Array(15, 2))
End Sub
・上記は、パス及びファイル名は対象のCSVファイルに変更して使用のこと。 ・読み込みのタイプは、Array(*, 2)のように文字形式の２を指定のこと。 ・本CSVファイルはフィ−ルド(列）が15であったので配列は15まで指定した ソフト上同じ内容を沢山書いてカッコ悪いと思う方は29-52項を参照のこと。

(4)．ファイルを開かずに読み取りセルへ1行ずつ書く
○●● ＣＳＶもファイルを開らかずに読み取れば速いか試したが、あまり早く なかった。(下記は画面の動き停止を入れて無いが入れても殆ど変わらず） 

Sub 例51k4()
Dim dat(15) As String
Dim fff As String
Const phn As String = "D:\test2\郵便番号"
Const fname1 As String = "13TOKYO.csv"
 
fff = phn & "\" & fname1
Application.StatusBar = "ファイル名( " & fname1 & " )読み込み中"

'txtデ−タ取り込み
    i = 1: j = 1
    Open fff For Input As #1
Do Until EOF(1)
    Input #1, dat(1), dat(2), dat(3), dat(4), dat(5), dat(6), _
     dat(7), dat(8), dat(9), dat(10), dat(11), dat(12), dat(13), _
     dat(14), dat(15)
'セルへ書き込み
    For j = 1 To 15
        Cells(i, j) = dat(j)
    Next
    i = i + 1
Loop
Close #1
End Sub

(5)．ファイルを開かずに読み取り後からセルへ記入
○●● 前(4)項は1行ずつセルへ書き込んでいるため時間が掛かる可能性があり、 一度配列へ代入し後から1行ずつセルへ書き込む方式にしてみた。 時間は前項と殆ど同じ。(下記は画面の動き停止を入れて無いが入れても殆ど変わらず） 

Sub 例51k5()
Sub Record6()
Dim dat(5000, 15) As String
Dim fff As String
Const phn As String = "D:\test2\郵便番号"
Const fname1 As String = "13TOKYO.csv"
 
fff = phn & "\" & fname1
Application.StatusBar = "ファイル名( " & fname1 & " )読み込み中"

'txtデ−タ取り込み
    i = 1: j = 1
    Open fff For Input As #1
Do Until EOF(1)
    Input #1, dat(i, 1), dat(i, 2), dat(i, 3), dat(i, 4), dat(i, 5), _
             dat(i, 6), dat(i, 7), dat(i, 8), dat(i, 9), dat(i, 10), _
        dat(i, 11), dat(i, 12), dat(i, 13), dat(i, 14), dat(i, 15)
     i = i + 1
Loop
Close #1
'セルへ書き込み
Range("a1").Select
 For ia = 1 To i - 1
    For j = 1 To 15
        Cells(ia, j) = dat(ia, j)
    Next
Next
End Sub

(6)．ファイルを開かずに読み取りセルへまとめて記入
○●● 前(5)項はセルは書き込むのに時間が掛かっていたので、Excelは二次元配列は ダイレクトにセルへ書き込めるのでその機能でセルへ記入した。 これはかなり早くなり満足できる結果となった。

・セルの１行目からの記入(当然０は無い)であり、セルと配列を合わせる 関係で、配列は1から(Option Base 1)を宣言する事。
・配列容量は取り合えず5000行としてあるが、必要に応じ変更の事
 

Option Base 1
Sub 例51k6()
Dim dat(5000, 15) As String
Dim fff As String
Const phn As String = "D:\test2\郵便番号"
Const fname1 As String = "13TOKYO.csv"

fff = phn & "\" & fname1
Application.StatusBar = "ファイル名( " & fname1 & " )読み込み中"

'txtデ−タ取り込み
    i = 1: j = 1
    Open fff For Input As #1
Do Until EOF(1)
    Input #1, dat(i, 1), dat(i, 2), dat(i, 3), dat(i, 4), dat(i, 5), _
             dat(i, 6), dat(i, 7), dat(i, 8), dat(i, 9), dat(i, 10), _
        dat(i, 11), dat(i, 12), dat(i, 13), dat(i, 14), dat(i, 15)
     i = i + 1
Loop
Close #1
'セルへ書き込み
    Range(Cells(1, 1), Cells(i - 1, 15)).Value = dat
End Sub

２９−５２．ＣＳＶファイル高速読み取り汎用版
○●●
・マクロに汎用性を持たせる為に列の最大値である256(Excel95/97/2000とも同じ)を設定。 （なお、配列を宣言するとメモリ−へエリアを確保するので、理想としては少ない数字の 　方がよいので、フィ−ルド数(列)が判っている場合はその数に変更した方がよい)
・このマクロでは、csvをtxtに変えています。csvとして残す場合は再度名前の変更 処理が必要。
 

Sub 例52()
Sub Macro4()
Dim fname1 As String 'csvファイル
Dim fname2 As String 'txtファイル
Dim lcsv As Integer
Dim fil(1 To 256) As Variant

'ダイアログ表示
     fname1 = Application.GetOpenFilename(Title:="CSVファイル指定")
     If fname1 = "False" Then
        MsgBox "ファイルを１個指定して下さい"
        Exit Sub
     End If
'拡張子
      lcsv = InStr(1, fname1, ".csv", 1)
      If lcsv = 0 Then
          MsgBox "拡張子「CSV」以外は指定出来ません"
          Exit Sub
      End If
'txt名
     fname2 = Mid(fname1, 1, lcsv - 1) & ".txt"

For i = 1 To 256
    fil(i) = Array(i, 2)
Next

 Application.StatusBar = "( " & fname1 & " )読み込み中"
 Name fname1 As fname2
'読み込み
        Workbooks.OpenText FileName:=fname2, DataType:=xlDelimited, _
        Comma:=True, FieldInfo:=fil
End Sub

２９−５３．オプションボックスの内容作成例
○●●
・下記マクロでは事前にUserForm1にオプションボックス(名前：cbo1）作って置く事。 ・オプションボックスへの登録は、UserForm1.cbo1.AddItem (op(i))で出来ます。 

Sub 例53()
ReDim op(1000) As String

'選択項目指定
    msg = "検索する列の項目セルを指定して下さい。" & Chr(10) _
    & "(その列の最初のセル)"
    On Error Resume Next
    Application.DisplayAlerts = False
    Set scel = Application.InputBox(msg, "セル指定", Type:=8)
    Application.DisplayAlerts = True
    If TypeName(scel) = "Nothing" Then
        MsgBox "セルを指定して下さい"
        End
    End If
    If scel = "" Then
        MsgBox "セルを指定して下さい"
        End
    End If
    
 Application.ScreenUpdating = False
    
'スタ−トセル
    scel.Select
    rst = ActiveCell.Row
    cst = ActiveCell.Column

'セル範囲
  Selection.SpecialCells(xlCellTypeLastCell).Select
      endr = ActiveCell.Row
      endc = ActiveCell.Column
      Range("A1").Select
      
'１列の同一文字抽出
Sheets.Add.Name = "dummy"
Sheets(sbase).Select
    Range(Cells(rst + 1, cst), Cells(endr, cst)).Select
    Selection.Copy
    Sheets("dummy").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range(Cells(1, 1), Cells(endr - 1, 1)).Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
  Range("A1").Select
j = 1
For i = 1 To endr - 1
    If op(j - 1) <> Cells(i, 1) Then
       op(j) = Cells(i, 1)
       j = j + 1
    End If
Next
opm = j - 1
'ダミ−シ−ト削除
    Application.DisplayAlerts = False
      ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True
'コンボボックスへ
For i = 1 To opm
  UserForm1.cbo1.AddItem (op(i))
Next
soki = 1
Sheets(sbase).Select
Range("A1").Select
End Sub

２９−５４．デ−タベ−スのHTML形式に変換(配列変数使用)
○●●
・Sheet1にあるデ−タベ−スをSheet2へWebで表示できるデ−タに変換します。

・実際にWebで表示する場合は、Sheet2を拡張子「.prn」で保存し、Excelを終了 してから、ディスクトップのマイコンピュ−タ-から対象の「***.prn」を 「***.html」に変えて下さい。

・上記の拡張子変換はマクロで簡単に行なうことできますが、下記マクロは では省略してあります。

・なお、26-52項（ＣＳＶファイル高速読み取り）、この29-54項及び 自動HTML変換を、サンプルNo[19]にまとめましたので、必要な方は ダウンロ−ドして使用して下さい。

※　配列変数を使用してHTMLに変換したこの方式は、時間的には高速に なりますが、文字フォントやセルの背景色等の変換は出来ません。 （Excelワ−クシ−トの内容をHTML変換はサンプルマクロ「KIweb」で 出来ます。
 

Dim i   As Integer   '数字カウント
Dim j  As Integer    '数字カウント
Dim cend  As Integer    '列
Dim rend  As Integer    '行
Dim hro   As Integer    'html行
Dim dbas As String   '１行分のデ−タ
Dim dt() As String
Dim tdat As Variant

Sub 例2954()
Application.ScreenUpdating = False
    Sheets("Sheet2").Select
    Columns("A:A").ColumnWidth = 255

'ヘッダ−部書込み
    hro = 1:       Cells(hro, 1) = "<HTML>"
    hro = hro + 1: Cells(hro, 1) = "<HEAD>"
    hro = hro + 1: Cells(hro, 1) = "<TITLE>" & dai & "</TITLE>"
    hro = hro + 1: Cells(hro, 1) = "</HEAD>"
    hro = hro + 1: Cells(hro, 1) = "<!-- このファイルは、KIDBhtml" & va & "で作成されました。-->"
'バックカラ−
    hro = hro + 1: Cells(hro, 1) = "<BODY BGCOLOR=#ffffbf>"
'表作成
    Sheets("Sheet1").Select
    tdat = Range("A1").CurrentRegion.Value
rend = UBound(tdat, 1)
cend = UBound(tdat, 2)
'テ−ブル作成
  dbas = "<TABLE BORDER>"
  表貼付
  
For i = 1 To rend
    Sheets("Sheet1").Select
    Application.StatusBar = "HTML変換中----　" & i & "/" & rend
    
ReDim dt(4)
    dt(0) = "<tr>"
    For j = 1 To cend
            If Trim(tdat(i, j)) = "" Then
                tdat(i, j) = " "         'ﾌﾞﾗﾝｸセルにhtmlﾌﾞﾗﾝｸ
            End If
    
      If j < 6 Then
            dt(0) = dt(0) & "<td>" & tdat(i, j) & "</td>"
      ElseIf j < 12 Then
            dt(1) = dt(1) & "<td>" & tdat(i, j) & "</td>"
      ElseIf j < 18 Then
            dt(2) = dt(2) & "<td>" & tdat(i, j) & "</td>"
      ElseIf j < 24 Then
            dt(3) = dt(3) & "<td>" & tdat(i, j) & "</td>"
      Else
            dt(4) = dt(4) & "<td>" & tdat(i, j) & "</td>"
      End If
    Next
    For n = 0 To 4
        If dt(n) <> "" Then
            dbas = dt(n)
            表貼付
        End If
    Next
    dbas = "</tr>"
    表貼付
Next
 
'最終処理
   Sheets("Sheet2").Select
    hro = hro + 1: Cells(hro, 1) = "</table>"
    hro = hro + 1: Cells(hro, 1) = "<BR>"
   
'更新日
    hro = hro + 1: Cells(hro, 1) = "作成日：　" & Date & "<BR>"
    hro = hro + 1: Cells(hro, 1) = "" & "<BR>"
   
   hro = hro + 1: Cells(hro, 1) = "</BODY>"
   hro = hro + 1: Cells(hro, 1) = "</HTML>"
   
 Application.ScreenUpdating = True
Sheets("Sheet2").Select
Application.StatusBar = "保存完了"
  msg = "ＨＴＭＬへ変換完了。"
       kesu = MsgBox(msg, 0, "KIDBhtml")
End Sub
'

Sub 表貼付()
   Sheets("Sheet2").Select
     hro = hro + 1
     Cells(hro, 1) = dbas
End Sub

２９−５５．マクロでハイパ−リンクからWebを開く
○●●
本マクロは、Webペ−ジのExcelへの取り込みにていて依頼があり、作成した ものです。55項・56項・57項を実施すればWebペ−ジの取り込みはできます。 しかし、56項に記載してあるWebペ−ジの読み込み完了のチェック方法に汎用性 がなく、ソフトとしてはボツにした。しかし別の読み込み完了チェック方法を 考え出したら再度作成するかもしれないので、忘れないようにここにメモとして 記載しました。 

Public Const fff As String = "http://excel-vba.hoops.ne.jp/"
Sub 例2955()
'リンク設定
　ThisWorkbook.Activate
　Sheets("Sheet3").Select
	Columns("I:I").ColumnWidth = 0
 	Range("I2").Select
	ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fff

'HPを開く
　Sheets("Sheet3").Select
 	Application.StatusBar = "HTMLファイルを開いています"
 	Range("I2").Select
　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
	Range("A2").Select
	例2956 'コピ−貼り付けへ
End Sub
上記マクロでWEBペ−ジが開くところまでは問題はありません。

２９−５６．Webペ−ジの画面コピ−とExcelシ−トへの貼り付け
○●●
各PCのスピ−ドやインタ−ネットの込み具合等でWebペ−ジの読み込み完了が異なる ため、読み込み完了チェックはかなり難しい。本例では一度ダミ−シ−ト(Sheet2) に貼り付けその内容に"このページについてのご意見"と言う文字があったら 読み込みが完了した事にしました。（各HPで異なり汎用性なし） 


Sub 例2956()
Application.ScreenUpdating = False
tim = Now + TimeValue("00:02:00")
Do
 SendKeys "%(EA)", True
 SendKeys "%(EC)", True
 
 ThisWorkbook.Activate
 Sheets("Sheet2").Select
  Range("A1").Select
  ActiveSheet.Paste
  Selection.SpecialCells(xlCellTypeLastCell).Select
      endr = ActiveCell.Row
'コピ−の内容チェック
If endr <> 1 Then
Set actv = Range(Cells(1, 1), Cells(endr, 1)).Find("このページについてのご意見")
            If actv Is Nothing Then
               GoTo pas1
            Else
              Exit Do
            End If
End If
pas1:
            
 'タイミング
        timck = Timer + 3
        Do
            If Timer > timck Then
                Exit Do
            End If
            DoEvents
        Loop
 
 If Now > tim Then
    MsgBox "２分待ちましたがデ−タを表示をませんでした" & Chr$(10) _
      & "現在込み合っていると思われるので時間を開けてトライして下さい"
        End
 End If
Loop
’閉じる
    SendKeys "%(FC)", True　’IE5用
    SendKeys "%(FX)", True　’Netscape用
'ブックの追加
    ThisWorkbook.Activate
    Sheets("Sheet1").Select
    Columns("A:A").ColumnWidth = 70
'貼り付け
   Range("A1").Select
   ActiveSheet.Paste
   Range("A1").Select
　　例2957　’ダミ−シ−トの内容削除
End Sub
実際のマクロでは、Sheet1でなく追加したシ−トに貼っていく。

２９−５７．ワ−クシ−トのデ−タ削除例
○●●
前項目でSheet2を読込み完了チェック用に使用しているが、このシ−ト は目的が完了したら消す必要があり（前回デ−タが残っていると連続貼り付け 時の判断が出来ない）作成。 

Sub 例2957()
'  図形削除
ThisWorkbook.Activate
Sheets("Sheet2").Select
    For Each zu In ActiveSheet.Shapes
        zu.Delete
    Next

Cells.Select
'セルのデ−タとカラ−削除
    Selection.ClearContents
    Selection.Interior.ColorIndex = xlNone
'罫線削除
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
'クリックボ−ドクリア
     Range("A1").Select
    Selection.Copy
     Application.CutCopyMode = False
End Sub
参考２９-７　マクロ内での待ち時間設定例
○●● 他のアプリケ−ションを起動した場合等で、マクロ内に待ち時間 を設定する必要があるケ−スがあるが、本項に待ち時間設定例を記述。 

[1] 少し時間を取りたい時使用（PCにより時間が大幅に異なる）
   For t1 = 1 To 10000
   	For t2 = 1 To 1000
   	Next
   Next

[2]　３秒間時間を取った例（DoEventsによりアプリケ−ションは読込んでいる）
   timck = Timer + 3
   Do
        If Timer > timck Then
             Exit Do
        End If
   DoEvents
   Loop

[3]　１０秒のカウントダウンをセルへ表示した例1
   tm = 10
   tma = tm: tm2 = 0: tim1 = 0
        timck = Timer + tm
   Do
        If Timer > tim1 Then
               Cells(1, 1) = tma
               tim1 = Timer + 1
               tm2 = tm2 + 1
               tma = tm - tm2
         End If
         If Timer > timck Then
               Exit Do
         End If
   Loop

[4] １０秒のカウントダウンをセルへ表示した例2
tm = 10
  For t = tm To 0 Step -1
 	Cells(1, 1) = t
 	Application.Wait (Now + TimeValue("00:00:01"))
 Next

[5]　４秒間待った例
  Application.Wait (Now + TimeValue("00:00:04"))

[6]　２分間を監視した例
 tim = Now + TimeValue("00:02:00")
 Do
 	If Now > tim Then
   		MsgBox "タシムオ−バ−"
      		Exit Do
 	End If
　　’-----実行するマクロ（省略）　---------　　
　Loop

[7]　５秒後にプロシージャ"Macro1"を実行
Application.OnTime Now + TimeValue("00:00:05"), "Macro1"

２９−５８．データベースのブランクと特殊文字の入替
○●●
本項は、00/6/10にS.Sさんから来た質問への返事
・質問内容は、「あるデータベースのある項目は通常8桁文字でなくてはならないのですが、 ブンランクが入っているため８桁をオーバーと認識され次工程の作業に支障をきたしてしま うことがありました。そのためマクロで自動的にブランクを削除したいのです」。

・ＤＢの途中に入っているブランクを詰めるのは少し面倒です(29-59に掲載）。 もしブランク削除でなく、ブランクの所を特定の文字か記号に入れ替えて問題が解決 するのであれば、本例のように簡単にできます。
 [1] 元のデータベース


[2] 下記マクロで、ブランクを***に置き換えたケ−ス

 

Sub 例2958()
Dim sel As Range
   Cells(1, 1).Select
    Selection.CurrentRegion.Select
    '
    For Each sel In Selection
        If sel = xlBlank Then
            sel.Value = "***"
        End If
    Next sel
    Cells(1, 1).Select
End Sub

２９−５９．データベースのブランクを詰める
○●● 本例は、前項[1] の元のデータベースのブランクを詰めたケース。 


Sub 例2959()
Dim dat1 As Variant
Dim dat2() As String

'2次元配列へ代入
  Sheets("Sheet1").Select
    Cells(1, 1).Select
    dat1 = Range("A1").CurrentRegion.Value
    rend = UBound(dat1, 1)
    cend = UBound(dat1, 2)
    end1 = rend * cend
    ReDim dat2(end1 + 1) As String
'1次元配列へ
    ia = 1
    For i = 1 To rend
        For j = 1 To cend
            dat2(ia) = dat1(i, j)
            ia = ia + 1
        Next
    Next
'ブランク削除
   For i = 1 To end1
      If dat2(i) = "" Then
         For j = i To end1
             dat2(j) = dat2(j + 1)
         Next
      End If
   Next
'元の2次元配列へ戻す
   ia = 1
    For i = 1 To rend
        For j = 1 To cend
            dat1(i, j) = dat2(ia)
            ia = ia + 1
        Next
    Next
'シ−トへ貼り付け
Sheets("Sheet2").Select
Range(Cells(1, 1), Cells(rend, cend)).Value = dat1
End Sub
・2次元配列へ代入（変数はVariant型である事）（UBoundで最終取得）

・2次元配列のままブランクを詰めるのは面倒なので1次元配列置き換えてから詰めた。

・ブランク判定は、""で行なっているがxlBlankでも同じこと（空白に見えてもスペ−ス が入っている場合は詰まりません）

・dat2(j + 1)で一つ後ろを前に移動させる関係で、配列数は余分に１個必要。 （If文で最終をガードする方法もあるが、 ReDim dat2(end1 + 1)のように+1の方が簡単）

・再貼り付けは、Range(***).Value = dat1　で容易に出来る。

２９−６０．ブック内全シートを対象に処理
○●● 本例は約10シートを１シートにまとめた例 

Public sname(16) As String  'シ−ト名
Public shsu As Integer      'シ−ト数
Sub 例2960()
 For Each sheet_name In Worksheets
        sname(i) = sheet_name.Name
        i = i + 1
    Next
    shsu = i - 1

'マクロ実行
For cn = 1 To shsu
 　Application.StatusBar = "一覧表作成----" & sname(cn)
   Windows(jname1).Activate　　'元のブック名（事前取得済み）
　　Sheets(sname(cn)).Select
'最終セル
      ActiveCell.SpecialCells(xlLastCell).Select
      endr = ActiveCell.Row
      endc = ActiveCell.Column
 If cn = 1 Then
    Range(Cells(1, 1), Cells(endr, endc)).Select
    Selection.Copy
    
    Windows(fname2).Activate　　'貼付け先ブック名（事前に追加済み）
    Sheets(sname2).Select　　　 '貼付け先シート名（事前に追加済み）
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
  Else
    Range(Cells(4, 1), Cells(endr, endc)).Select
    Selection.Copy
  
    Windows(fname2).Activate
    Sheets(sname2).Select
    ActiveCell.SpecialCells(xlLastCell).Select
    endr1 = ActiveCell.Row
    Cells(endr1 + 1, 1).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
  End If
    Range("A4").Select
Next
特にノウハウ的な事項はないが、貼り付ける時(endr1 + 1, 1)のように+1する事。

２９−６１．検索　＆　貼付け例
○●● 本例は14-31(文字変換)と実行内容は殆ど同じであるが、約7000のデータを ブックを切替えて処理すると時間が掛かる為、一方のデータを変数に代入して 処理しました。以下処理の内容概略
・"Etotal"ファイルのＡ列と、"fname1"ファイルのＡ列が検索のキ−ワード。
・キ−ワードが一致した行の"Etotal"Ｍ列データを"fname1"ＱＡ列へ貼付け。
・本例では一致なしの場合の処理は省略。


Dim yaku() As String
Sub 例2961()
'Etotalファイル最終セル
 ReDim yaku(1, 7000)
　　　Windows("Etotal").Activate
     Range("A5").Select
      ActiveCell.SpecialCells(xlLastCell).Select
      cen2 = ActiveCell.Row
  
   Range("A1").Select
   For i = 1 To cen2
       yaku(0, i) = Cells(i, 1)
       yaku(1, i) = Cells(i, 13)
   Next
   
   Windows("fname1").Activate
   Range("A5").Select
      ActiveCell.SpecialCells(xlLastCell).Select
      cen1 = ActiveCell.Row
   
For i = 2 To cen2
Application.StatusBar = "スタート価格貼付け---- " & i & "/" & cen2
      jp = yaku(0, i)
     
    Set actv = Range(Cells(4, 1), Cells(cen1, 1)) _
    .Find(jp, , , xlWhole, xlByColumns, xlNext, False)
            If actv Is Nothing Then
               '本例では一致なしの場合の処理は省略
            Else
              actv.Select
              ra = ActiveCell.Row
              Cells(ra, 17) = yaku(1, i)
            End If
Next

(29-1〜29-20) (29-21〜29-35) (29-36〜29-50) (29-51〜29-61) (29-62〜29-73) (29-74〜 　　)

目次へ戻る

テレワークならECナビ Yahoo 楽天 LINEがデータ消費ゼロで月額500円〜！
無料ホームページ 無料のクレジットカード 海外格安航空券　海外旅行保険が無料！ 海外ホテル